home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGofer 0.22d / MacGofer Sources / preds.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-03-31  |  23.2 KB  |  793 lines  |  [TEXT/MPS ]
  1. /* --------------------------------------------------------------------------
  2.  * preds.c:     Copyright (c) Mark P Jones 1991-1993.   All rights reserved.
  3.  *              See goferite.h for details and conditions of use etc...
  4.  *              Gofer version 2.28 January 1993
  5.  *
  6.  *        Added stack checks KH (20/2/92)
  7.  *
  8.  * Part of type checker dealing with predicates and entailment.
  9.  * ------------------------------------------------------------------------*/
  10.  
  11. #if MPW
  12. #pragma segment Preds
  13. #endif
  14.  
  15. Bool anyEvidence  = TRUE;        /* no need to search for `best'    */
  16.                     /* evidence - any will do.       */
  17.  
  18. Int  maxEvidLevel = 8;            /* maximum no. of dict selects     */
  19.  
  20. Bool silentEvFail = TRUE;        /* TRUE => fail silently if       */
  21.                     /*         maxEvidLevel exceeded   */
  22.  
  23. /* --------------------------------------------------------------------------
  24.  * Local function prototypes:
  25.  * ------------------------------------------------------------------------*/
  26.  
  27. static Cell   local assumeEvid        Args((Cell,Int));
  28. static List   local makeEvidArgs      Args((List,Int));
  29. static Void   local markPred          Args((Cell));
  30. static List   local copyPreds         Args((List));
  31. static Cell   local copyPred          Args((Cell,Int));
  32. static Void   local qualify           Args((List,Cell));
  33. static Void   local qualifyBinding    Args((List,Cell));
  34.  
  35. static Cell   local instsOverlap      Args((Inst,Inst));
  36. static Bool   local instsCompare      Args((Inst,Inst));
  37.  
  38. static Bool   local oneWayMatches     Args((Cell,Int,Cell,Int));
  39. static Bool   local oneWayTypeMatches Args((Type,Int,Type,Int));
  40.  
  41. static Cell   local proveFrom         Args((List,Cell,Int));
  42. static List   local evidFrom          Args((Cell,Int));
  43. static Void   local explicitProve     Args((Int,String,Cell,List,List));
  44. static Cell   local addEvidArgs          Args((Int,String,Cell,List,List,Cell));
  45. static Void   local cantProve          Args((Int,String,List,Cell,Cell));
  46. static List   local simplify          Args((List));
  47. static Void   local overEvid          Args((Cell,Cell));
  48.  
  49. static List   local elimConstPreds    Args((Int,String,Cell,List));
  50. static Bool   local scanPred          Args((Cell,Int));
  51. static Bool   local scanTyvar         Args((Int));
  52. static Bool   local scanType          Args((Type,Int));
  53.  
  54. static Cell   local makeInst          Args((Int,String,Cell,Cell,Int));
  55. static Cell   local makeDict          Args((Cell,Int));
  56.  
  57. static Void   local indexPred          Args((Class,Cell,Int));
  58. static Void   local indexType          Args((Type,Int));
  59. static Void   local indexLeaf          Args((Cell));
  60.  
  61. /* --------------------------------------------------------------------------
  62.  * Predicate sets:
  63.  *
  64.  * A predicate set is represented by a list of triples (pi, o, used)
  65.  * where o is the offset for types in pi, with evidence required at the
  66.  * node pointed to by used (which is taken as a dictionary parameter if
  67.  * no other evidence is available).  Note that the used node will be
  68.  * overwritten at a later stage if evidence for that predicate is found
  69.  * subsequently.
  70.  * ------------------------------------------------------------------------*/
  71.  
  72. static List preds;               /* current predicate list       */
  73.  
  74. static Cell local assumeEvid(pi,o)     /* add predicate pi (offset o) to   */
  75. Cell pi;                   /* preds with new dictionary var and*/
  76. Int  o; {                   /* return that dictionary variable  */
  77.     Cell nd = inventDictVar();
  78.     preds   = cons(triple(pi,mkInt(o),nd),preds);
  79.     return nd;
  80. }
  81.  
  82. static List local makeEvidArgs(qs,o)   /* make list of predicate assumps.  */
  83. List qs;                   /* from qs (offset o), with new dict*/
  84. Int  o; {                   /* vars for each predicate       */
  85.     List result;
  86.     for (result=NIL; nonNull(qs); qs=tl(qs))
  87.     result = cons(triple(hd(qs),mkInt(o),inventDictVar()),result);
  88.     return rev(result);
  89. }
  90.  
  91. static Void local markPred(pi)           /* marked fixed type variables in pi*/
  92. Cell pi; {
  93.     Cell cl = fst3(pi);
  94.     Int  o  = intOf(snd3(pi));
  95.  
  96.     for (; isAp(cl); cl=fun(cl))
  97.     markType(arg(cl),o);
  98. }
  99.  
  100. static List local copyPreds(qs)        /* copy list of predicates          */
  101. List qs; {
  102.     List result;
  103.     for (result=NIL; nonNull(qs); qs=tl(qs)) {
  104.     Cell pi = hd(qs);
  105.     result  = cons(copyPred(fst3(pi),intOf(snd3(pi))),result);
  106.     }
  107.     return rev(result);
  108. }
  109.  
  110. static Cell local copyPred(pi,o)    /* copy single predicate (or part  */
  111. Cell pi;                /* thereof) ...               */
  112. Int  o; {
  113.     if (isAp(pi)) {
  114.     Cell temp = copyPred(fun(pi),o);/* to ensure correct order of eval.*/
  115.     return ap(temp,copyType(arg(pi),o));
  116.     }
  117.     else
  118.     return pi;
  119. }
  120.  
  121. static Void local qualify(qs,alt)    /* Add extra dictionary args to       */
  122. List qs;                /* qualify alt by predicates in qs */
  123. Cell alt; {                /* :: ([Pat],Rhs)           */
  124.     List ds;
  125.     for (ds=NIL; nonNull(qs); qs=tl(qs))
  126.     ds = cons(thd3(hd(qs)),ds);
  127.     fst(alt) = revOnto(ds,fst(alt));
  128. }
  129.  
  130. static Void local qualifyBinding(qs,b)    /* Add extra dict args to each       */
  131. List qs;                /* alternative in function binding */
  132. Cell b ; {
  133.     if (!isVar(fst(b)))            /* check for function binding       */
  134.     internal("qualifyBinding");
  135.     map1Proc(qualify,qs,snd(snd(b)));
  136. }
  137.  
  138. /* --------------------------------------------------------------------------
  139.  * Check for overlapping instances of class:
  140.  * ------------------------------------------------------------------------*/
  141.  
  142. static Cell local instsOverlap(ia,ib)    /* see if heads of instances can be*/
  143. Inst ia, ib; {                /* unified               */
  144.     Int  alpha, beta;
  145.     Cell pa, pb;
  146.  
  147.     emptySubstitution();
  148.     matchMode = FALSE;
  149.     alpha     = newKindedVars(inst(ia).sig);
  150.     pa          = inst(ia).head;
  151.     beta      = newKindedVars(inst(ib).sig);
  152.     pb          = inst(ib).head;
  153.     while (isAp(pa) && isAp(pb)) {
  154.     if (!unify(arg(pa),alpha,arg(pb),beta))
  155.         return NIL;
  156.     pa = fun(pa);
  157.     pb = fun(pb);
  158.     }
  159.     return copyPred(inst(ia).head,alpha);
  160. }
  161.  
  162. static Bool local instsCompare(ia,ib)    /* see if ib is an instance of ia  */
  163. Inst ia, ib; {
  164.     Int  alpha, beta;
  165.     Cell pa, pb;
  166.  
  167.     emptySubstitution();
  168.     alpha = newKindedVars(inst(ia).sig);
  169.     pa      = inst(ia).head;
  170.     beta  = newKindedVars(inst(ib).sig);
  171.     pb      = inst(ib).head;
  172.     return oneWayMatches(pa,alpha,pb,beta);
  173. }
  174.  
  175. Void insertInst(line,cl,in)        /* insert instance into class       */
  176. Int   line;
  177. Class cl;
  178. Inst  in; {
  179.     List done = NIL;
  180.     List ins  = class(cl).instances;
  181.  
  182.     while (nonNull(ins)) {
  183.     Cell tmp = tl(ins);
  184.     Cell pi  = instsOverlap(in,hd(ins));
  185.     if (nonNull(pi)) {
  186.         Bool bef = instsCompare(hd(ins),in);
  187.         Bool aft = instsCompare(in,hd(ins));
  188.         if (bef==aft) {
  189.         class(cl).instances = revOnto(done,ins);
  190.         ERROR(line) "Overlapping instances for class \"%s\"",
  191.                 textToStr(class(inst(in).cl).text)
  192.         ETHEN
  193.         ERRTEXT "\n*** This instance   : " ETHEN ERRPRED(inst(in).head);
  194.         ERRTEXT "\n*** Overlaps with   : " ETHEN
  195.                            ERRPRED(inst(hd(ins)).head);
  196.         ERRTEXT "\n*** Common instance : " ETHEN
  197.                                ERRPRED(pi);
  198.         ERRTEXT "\n"
  199.         EEND;
  200.         }
  201.         if (bef)
  202.         break;
  203.     }
  204.     tl(ins) = done;
  205.     done    = ins;
  206.     ins     = tmp;
  207.     }
  208.     class(cl).instances = revOnto(done,cons(in,ins));
  209. }
  210.  
  211. /* --------------------------------------------------------------------------
  212.  * One way matching of instance headers with predicates:
  213.  * ------------------------------------------------------------------------*/
  214.  
  215. static Bool local oneWayMatches(p1,o1,p2,o2)
  216. Cell p1, p2;                /* determine if S(p1,o1) = (p2,o2) */
  217. Int  o1, o2; {                /* for some substitution S       */
  218.     while (isAp(p1) && isAp(p2)) {
  219.     if (!oneWayTypeMatches(arg(p1),o1,arg(p2),o2))
  220.         return FALSE;
  221.     p1 = fun(p1);
  222.     p2 = fun(p2);
  223.     }
  224.     return TRUE;
  225. }
  226.  
  227. static Bool local oneWayTypeMatches(t1,o1,t2,o2)
  228. Type t1, t2;                /* determine if S(t1,o1) = (t2,o2) */
  229. Int  o1, o2; {                /* for some substitution S       */
  230.     Tyvar *tyv;
  231.     Cell  h1,h2;            /* heads of (t1,o1) and (t2,o2)       */
  232.     Int   a1,a2;            /* #args of (t1,o1) and (t2,o2)       */
  233.  
  234.     STACK_CHECK;            /* KH */
  235.  
  236.     while (h1=getDerefHead(t1,o1),    /* eliminate synonym at hd (t1,o1) */
  237.        a1=argCount,
  238.        (isSynonym(h1) && tycon(h1).arity==a1)) {
  239.     expandSynonym(h1,&t1,&o1);
  240.     if (isOffset(t1)) {
  241.         tyv = tyvar (o1 + offsetOf(t1));
  242.         t1  = tyv -> bound;
  243.         o1  = tyv -> offs;
  244.     }
  245.     }
  246.  
  247.     deRef(tyv,t2,o2);            /* eliminate synonym at hd (t2,o2) */
  248.     while (h2=getDerefHead(t2,o2),
  249.        a2=argCount,
  250.        (isSynonym(h2) && tycon(h2).arity==a2)) {
  251.     expandSynonym(h2,&t2,&o2);
  252.     deRef(tyv,t2,o2);
  253.     }
  254.  
  255.     /* there are certain conditions under which there is no way to match   */
  256.     /* the type (t1,o1) with (t2,o2):                       */
  257.     /* - if (t1,o1) has more arguments than (t2,o2)               */
  258.     /* - if (t1,o1) has fewer arguments than (t2,o2) and h1 not a variable */
  259.     /* - if h1 not a variable and h2!=h1                   */
  260.  
  261.     if (a1>a2 || (!isOffset(h1) && (a1<a2 || h1!=h2)))
  262.     return FALSE;
  263.  
  264.     while (isAp(t1)) {            /* loop through arguments       */
  265.     if (!oneWayTypeMatches(arg(t1),o1,arg(t2),o2))
  266.         return FALSE;
  267.     t1 = fun(t1);
  268.     t2 = fun(t2);
  269.     deRef(tyv,t2,o2);
  270.     }
  271.  
  272.     if (isOffset(t1)) {            /* (t1,o1) is a variable       */
  273.     tyv = tyvar(o1 + offsetOf(t1));
  274.     if (tyv->bound)
  275.         return sameType(tyv->bound,tyv->offs,t2,o2);
  276.         if (!eqKind(tyv->kind,getKind(t2,o2)))
  277.         return FALSE;
  278.     tyv->bound = t2;
  279.     tyv->offs  = o2;
  280.     }
  281.     return TRUE;
  282. }
  283.  
  284. Bool typeInstOf(type,pt)        /* test if type is instance of poly*/
  285. Type type, pt; {            /* type pt (not-overloaded)       */
  286.     Bool result;
  287.     Int  alpha = 0, beta = 0;
  288.     typeChecker(RESET);
  289.  
  290.     instantiate(pt);            /* instantiate given polytype       */
  291.     alpha = typeOff;
  292.     pt    = typeIs;
  293.     if (predsAre)
  294.     internal("typeInstOf"); 
  295.  
  296.     instantiate(type);            /* and type against which it will  */
  297.     beta = typeOff;            /* be compared               */
  298.     type = typeIs;
  299.     if (predsAre)
  300.     internal("typeInstOf"); 
  301.  
  302.     result = oneWayTypeMatches(pt,alpha,type,beta);
  303.     typeChecker(RESET);
  304.     return result;
  305. }
  306.  
  307. /* --------------------------------------------------------------------------
  308.  * Predicate entailment:
  309.  * ------------------------------------------------------------------------*/
  310.  
  311. static Cell  classProve;
  312. static Cell  predProve;
  313. static Int   offsetProve;
  314. static Int   evDepth;
  315. static Int   evidLevel;
  316.  
  317. static Cell local proveFrom(qs,pi,o)    /* Construct evidence for predicate*/
  318. List  qs;                /* pi, offset o from predicates qs,*/
  319. Cell  pi;                               /* returning NIL if qs ||- (pi,o)  */
  320. Int   o; {                              /* does not hold.                  */
  321.     List  bestEvid  = NIL;
  322.     Int   bestDepth = (-1);
  323.  
  324.     classProve  = getHead(pi);
  325.     predProve   = pi;
  326.     offsetProve = o;
  327.     evidLevel   = 0;
  328.  
  329.     for (; nonNull(qs); qs=tl(qs)) {
  330.     Cell qpi   = hd(qs);
  331.     List dSels = evidFrom(fst3(qpi),intOf(snd3(qpi)));
  332.  
  333.     if (evDepth>=0 && (isNull(bestEvid) || evDepth<bestDepth)) {
  334.         bestEvid  = revOnto(dSels,thd3(qpi));
  335.         bestDepth = evDepth;
  336.         if (anyEvidence)
  337.         return bestEvid;
  338.     }
  339.     }
  340.     return bestEvid;
  341. }
  342.  
  343. static List local evidFrom(pi,o)    /* recursive part of proveFrom       */
  344. Cell pi;                /* return list of dict selectors   */
  345. Int  o; {                /* for optimal (shortest) evidence */
  346.     Class cpi        = getHead(pi);    /* returns evDepth for number of   */
  347.     List  bestYet   = NIL;        /* selectors used, or (-1) if no   */
  348.     Int   bestDepth = (-1);        /* solution possible.           */
  349.     Int   doffs;
  350.     Int   beta;
  351.     List  cs, is;
  352.  
  353.     if (evidLevel++ >= maxEvidLevel) {    /* crude attempt to catch loops       */
  354.     if (silentEvFail)
  355.         goto end;
  356.  
  357.     ERROR(0) "Possible loop for instance " ETHEN
  358.          ERRPRED(copyPred(predProve,offsetProve));
  359.     ERRTEXT  "\n"
  360.     EEND;
  361.     }
  362.  
  363.     if (classProve==cpi) {                /* preds match?       */
  364.     Cell pi1 = pi;
  365.     Cell pi2 = predProve;
  366.     do {
  367.         if (!sameType(arg(pi1),o,arg(pi2),offsetProve))
  368.         break;
  369.         pi1 = fun(pi1);
  370.         pi2 = fun(pi2);
  371.     } while (isAp(pi1) && isAp(pi2));
  372.  
  373.     if (!isAp(pi1) && !isAp(pi2)) {
  374.         evDepth = 0;
  375.         return NIL;
  376.     }
  377.     }
  378.  
  379.     doffs = 1 + class(cpi).numMembers;            /* 1st superclass  */
  380.  
  381.     beta  = newKindedVars(class(cpi).sig);        /* match predicate */
  382.     if (!oneWayMatches(class(cpi).head,beta,pi,o))    /* against class   */
  383.     internal("evidFrom");                /* header       */
  384.  
  385.     for (cs=class(cpi).supers; nonNull(cs); cs=tl(cs)) {/* scan supers...  */
  386.     List dSels = evidFrom(hd(cs),beta);
  387.     if (evDepth>=0 && (isNull(bestYet) || evDepth+1<bestDepth)) {
  388.         bestYet   = cons(mkSelect(doffs),dSels);
  389.         bestDepth = evDepth+1;
  390.         if (anyEvidence)
  391.         goto end;
  392.     }
  393.     doffs++;
  394.     }
  395.  
  396.     for (is=class(cpi).instances; nonNull(is); is=tl(is)) {
  397.     Inst in = hd(is);                /* look through       */
  398.     beta    = newKindedVars(inst(in).sig);        /* instances       */
  399.     if (oneWayMatches(inst(in).head,beta,pi,o)) {
  400.         for (cs=inst(in).specifics; nonNull(cs); cs=tl(cs)) {
  401.         List dSels = evidFrom(hd(cs),beta);
  402.         if (evDepth>=0 && (isNull(bestYet) || evDepth+1<bestDepth)) {
  403.             bestYet   = cons(mkSelect(doffs),dSels);
  404.             bestDepth = evDepth+1;
  405.             if (anyEvidence)
  406.             goto end;
  407.         }
  408.         doffs++;
  409.         }
  410.         break; /* at most one instance matches... */
  411.     }
  412.         else
  413.         freeTypeVars(beta);
  414.     }
  415.  
  416. end:evidLevel--;
  417.     evDepth = bestDepth;
  418.     return bestYet;
  419. }
  420.  
  421. static Void local explicitProve(l,wh,e,given,reqd)
  422. Int    l;                /* construct evidence for reqd       */
  423. String wh;                /* predicates from given preds       */
  424. Cell   e;
  425. List   given, reqd; {
  426.     for (; nonNull(reqd); reqd=tl(reqd)) {
  427.     Cell pi = hd(reqd);
  428.     Cell ev = proveFrom(given,fst3(pi),intOf(snd3(pi)));
  429.     if (isNull(ev))
  430.         cantProve(l,wh,copyPreds(given),e,
  431.               copyPred(fst3(pi),intOf(snd3(pi))));
  432.     overEvid(thd3(pi),ev);
  433.     }
  434. }
  435.  
  436. static Cell local addEvidArgs(l,wh,e,given,reqd,f)
  437. Int    l;
  438. String wh;
  439. Cell   e;
  440. List   given, reqd;
  441. Cell   f; {
  442.     for (; nonNull(reqd); reqd=tl(reqd)) {
  443.     Cell pi = hd(reqd);
  444.     Cell ev = proveFrom(given,fst3(pi),intOf(snd3(pi)));
  445.     if (isNull(ev))
  446.         cantProve(l,wh,copyPreds(given),e,
  447.               copyPred(fst3(pi),intOf(snd3(pi))));
  448.     f = ap(f,ev);
  449.     }
  450.     return f;
  451. }
  452.  
  453. static Void local cantProve(l,wh,context,e,pi)
  454. Int    l;                /* produce error message when an   */
  455. String wh;                /* instance of a class cannot be   */
  456. List   context;                /* constructed               */
  457. Cell   e;
  458. Cell   pi; {
  459.     ERROR(l) "Cannot derive instance in %s", wh ETHEN
  460.     ERRTEXT  "\n*** Expression        : " ETHEN ERREXPR(e);
  461.     ERRTEXT  "\n*** Context           : " ETHEN ERRCONTEXT(context);
  462.     ERRTEXT  "\n*** Required instance : " ETHEN ERRPRED(pi);
  463.     ERRTEXT  "\n"
  464.     EEND;
  465. }
  466.  
  467. /* --------------------------------------------------------------------------
  468.  * Predicate set Simplification:
  469.  *
  470.  * This function calculates a minimal equivalent subset of a given set of
  471.  * predicates.  I believe this algorithm will work for any entailment
  472.  * relation, although I have only checked this for the particular relation
  473.  * coded in the above.
  474.  * ------------------------------------------------------------------------*/
  475.  
  476. static List local simplify(qs)        /* Simplify predicates in qs,      */
  477. List qs; {                /* returning equiv minmal subset   */
  478.     List result = qs;
  479.     Int  n      = length(qs);
  480.  
  481.     while (0<n--) {
  482.     Cell pi = hd(result);
  483.     Cell ev = proveFrom(tl(result),fst3(pi),intOf(snd3(pi)));
  484.     if (nonNull(ev)) {
  485.         overEvid(thd3(pi),ev);
  486.         result = tl(result);
  487.     }
  488.     else {
  489.         Cell temp  = tl(result);
  490.         tl(result) = NIL;
  491.         result     = appendOnto(temp,result);
  492.     }
  493.     }
  494.     return result;
  495. }
  496.  
  497. static Void local overEvid(c,ev)    /* overwrite evidence (possibly       */
  498. Cell c;                    /* including indirection; select0) */
  499. Cell ev; {
  500.     if (isPair(ev) && isSelect(fst(ev)))
  501.     overwrite(c,ev);        /* overwrite with dict selection   */
  502.     else {
  503.     fst(c) = mkSelect(0);        /* indirect to dict variable       */
  504.     snd(c) = ev;
  505.     }
  506. }
  507.  
  508. /* --------------------------------------------------------------------------
  509.  * Deal with constant and locally constant predicates:
  510.  * ------------------------------------------------------------------------*/
  511.  
  512. static Int numFixedVars;        /* number of fixed vars found       */
  513.  
  514. static List local elimConstPreds(l,wh,e,ps)
  515. Int    l;
  516. String wh;
  517. Cell   e;
  518. List   ps; {
  519.     List qs = NIL;
  520.  
  521.     while (nonNull(preds)) {
  522.     Cell pi = hd(preds);
  523.     Cell nx = tl(preds);
  524.  
  525.     numFixedVars = 0;
  526.     if (scanPred(fst3(pi),intOf(snd3(pi)))) {    /* contains generic*/
  527.         tl(preds) = qs;
  528.         qs          = preds;
  529.     }
  530.     else if (numFixedVars>0) {            /* only fixed vars */
  531.         tl(preds) = ps;
  532.         ps          = preds;
  533.     }
  534.     else                        /* constant types  */
  535.         overwrite(thd3(pi),makeInst(l,wh,e,fst3(pi),intOf(snd3(pi))));
  536.  
  537.     preds = nx;
  538.     }
  539.     preds = qs;
  540.     return ps;
  541. }
  542.  
  543. static Bool local scanPred(pi,o)    /* scan pred (pi,o) to determine if*/
  544. Cell pi;                /* it is constant or locally-const */
  545. Int  o; {                /* by counting fixed & generic vars*/
  546.     for (; isAp(pi); pi=fun(pi))
  547.     if (scanType(arg(pi),o))
  548.         return TRUE;
  549.     return FALSE;
  550. }
  551.  
  552. static Bool local scanTyvar(vn)        /* return TRUE if type var contains*/
  553. Int vn; {                /* a generic variable, counting the*/
  554.     Tyvar *tyv = tyvar(vn);        /* number of fixed variables       */
  555.  
  556.     if (tyv->bound)
  557.     return scanType(tyv->bound, tyv->offs);
  558.     else if (tyv->offs == FIXED_TYVAR) {
  559.     numFixedVars++;
  560.     return FALSE;
  561.     }
  562.     return TRUE;
  563. }
  564.  
  565. static Bool local scanType(t,o)        /* Return TRUE if (t,o) contains   */
  566. Type t;                 /* a generic variable           */
  567. Int  o; {
  568.     
  569.     STACK_CHECK;            /* KH */
  570.  
  571.     switch (whatIs(t)) {
  572.     case AP      : return scanType(fst(t),o) || scanType(snd(t),o);
  573.     case OFFSET  : return scanTyvar(o+offsetOf(t));
  574.     case INTCELL : return scanTyvar(intOf(t));
  575.     }
  576.     return FALSE;
  577. }
  578.  
  579. /* -----------------------------------------------------------------------
  580.  * Dictionary construction:
  581.  *
  582.  * 0 | class(c).numMembers | class(c).numSupers | inst(in).numSpecifics |
  583.  * ----------------------------------------------------------------------- */
  584.  
  585. static Cell   instPred;
  586. static Int    instOffs;
  587. static Int    instDepth;
  588. static Cell   instExpr;
  589. static String instWhere;
  590. static Int    instLine;
  591.  
  592. static Cell local makeInst(l,wh,e,pi,o)    /* Build instance, keeping track of*/
  593. Int    l;                /* top-level required instance for */
  594. String wh;                /* benefit of error reporting...   */
  595. Cell   e;
  596. Cell   pi;
  597. Int    o; {
  598.     Cell result;
  599.  
  600.     instPred  = pi;
  601.     instOffs  = o;
  602.     instDepth = 0;
  603.     instExpr  = e;
  604.     instWhere = wh;
  605.     instLine  = l;
  606.     result    = makeDict(pi,o);
  607.     instPred  = NIL;
  608.     instExpr  = NIL;
  609.     return result;
  610. }
  611.  
  612. static Idx  lastIdx, currIdx;        /* used to describe position in idx*/
  613.  
  614. static Cell local makeDict(pi,o)    /* Build dictionary for predicate  */
  615. Cell   pi;
  616. Int    o; {
  617.     Class c = getHead(pi);
  618.     List  xs, is, ds;
  619.     Int   alpha, beta, doffs;
  620.     Dict  dc;
  621.     Inst  in;
  622.  
  623.     STACK_CHECK;                    /* KH */
  624.  
  625.     indexPred(c,pi,o);                              /* dict has already*/
  626.     if (currIdx!=NODICT)                /* been built?     */
  627.     return dict(currIdx);
  628.  
  629.     for (xs=class(c).instances; nonNull(xs); xs=tl(xs)){/* No; then try and*/
  630.     in   = hd(xs);                    /* find a matching */
  631.     beta = newKindedVars(inst(in).sig);        /* instance to use */
  632.         if (oneWayMatches(inst(in).head,beta,pi,o))    /* to construct the*/
  633.         break;                    /* required dict   */
  634.     else
  635.         freeTypeVars(beta);
  636.     }
  637.  
  638.     if (isNull(xs)) {                    /* No suitable inst*/
  639.     clearMarks();
  640.     ERROR(instLine) "Cannot derive instance in %s", instWhere ETHEN
  641.     ERRTEXT        "\n*** Expression        : " ETHEN
  642.         ERREXPR(instExpr);
  643.     ERRTEXT        "\n*** Required instance : " ETHEN
  644.     ERRPRED(copyPred(instPred,instOffs));
  645.     if (instDepth>0) {
  646.         ERRTEXT     "\n*** No subdictionary  : " ETHEN
  647.         ERRPRED(copyPred(pi,o));
  648.     }
  649.     ERRTEXT  "\n"
  650.     EEND;
  651.     }
  652.  
  653.     alpha = newKindedVars(class(c).sig);        /* match against   */
  654.     if (!oneWayMatches(class(c).head,alpha,pi,o))    /* class header       */
  655.     internal("makeDict");
  656.  
  657.     instDepth++;
  658.  
  659.     dc       = idx(lastIdx).match            /* alloc new dict  */
  660.          = newDict(1 + class(c).numMembers        /* and add to index*/
  661.              + class(c).numSupers
  662.              + inst(in).numSpecifics);
  663.     dict(dc) = mkDict(dc);                /* self reference  */
  664.     doffs    = 1 + class(c).numMembers;
  665.     for (xs=class(c).supers; nonNull(xs); xs=tl(xs))    /* super classes   */
  666.     dict(dc+doffs++) = makeDict(hd(xs),alpha);
  667.     for (xs=inst(in).specifics; nonNull(xs); xs=tl(xs))    /* specifics       */
  668.     dict(dc+doffs++) = makeDict(hd(xs),beta);
  669.  
  670.     xs = class(c).members;                /* member function */
  671.     ds = class(c).defaults;                /* implementations */
  672.     is = inst(in).implements;
  673.     for (doffs=1; nonNull(xs); xs=tl(xs)) {
  674.     if (nonNull(is) && nonNull(hd(is)))
  675.         dict(dc+doffs++) = ap(hd(is),dict(dc));
  676.     else if (nonNull(ds) && nonNull(hd(ds)))
  677.             dict(dc+doffs++) = ap(hd(ds),dict(dc));
  678.     else
  679.         dict(dc+doffs++) = ap(nameUndefMem,hd(xs));
  680.  
  681.     if (nonNull(is)) is=tl(is);
  682.     if (nonNull(ds)) ds=tl(ds);
  683.     }
  684.  
  685. #ifdef DEBUG_CODE
  686. printf("Just made dictionary {dict%d}@%d for ",dc,dict(dc));
  687. printPred(stdout,copyPred(pi,o));
  688. putchar('\n');
  689. printf("breakdown = 1+%d+%d+%d\n",class(c).numMembers,
  690.                   class(c).numSupers,
  691.                   inst(in).numSpecifics);
  692. {
  693.     int i;
  694.     int size = 1+class(c).numMembers+class(c).numSupers+inst(in).numSpecifics;
  695.     for (i=0; i<size; i++) {
  696.          printf("dict(%d) = ",dc+i);
  697.          printExp(stdout,dict(dc+i));
  698.          putchar('\n');
  699.     }
  700.     printf("--------------------\n");
  701. }
  702. #endif
  703.     instDepth--;
  704.     return dict(dc);
  705. }
  706.  
  707. /* --------------------------------------------------------------------------
  708.  * Locate entry in an index corresponding to a given (constant) predicate:
  709.  * ------------------------------------------------------------------------*/
  710.  
  711. static Idx firstIdx;
  712.  
  713. static Void local indexPred(c,pi,o)    /* scan over a monopredicate (i.e a*/
  714. Class c;                /* predicate with monotype args),  */
  715. Cell  pi;                /* producing an indexing string of */
  716. Int   o; {                /* type constrs, and using them to */
  717.     firstIdx =                /* move through a particular index */
  718.     lastIdx  =
  719.     currIdx  = class(c).dictIndex;
  720.     for (; isAp(pi); pi=fun(pi))
  721.      indexType(arg(pi),o);
  722.     class(c).dictIndex = firstIdx;
  723. }
  724.  
  725. static Void local indexType(t,o)    /* scan a monotype as part of the  */
  726. Type t;                    /* indexPred process.           */
  727. Int  o; {
  728.     Cell  temp;
  729.     Tyvar *tyv;
  730.     
  731.     STACK_CHECK;            /* KH */
  732.  
  733.     for (;;) {                /* dereference bound vars/synonyms */
  734.     deRef(tyv,t,o);
  735.     if (tyv) internal("indexType");    /* monotypes cannot contain tyvars */
  736.  
  737.     temp = getDerefHead(t,o);    /* check for type synonym...       */
  738.     if (isSynonym(temp) && argCount==tycon(temp).arity)
  739.         expandSynonym(temp,&t,&o);
  740.     else
  741.         break;
  742.     }
  743.  
  744.     /* now we've `evaluated (t,o) to whnf': Con t1 t2 ... tn, we output the*/
  745.     /* constructor Con as a leaf and then go thru' tn, ..., t2, t1 in turn.*/
  746.     /* Admittedly, this gives a less than intuitive mapping of monopreds to*/
  747.     /* strings of type constructors, but it is sufficient for the moment.  */
  748.  
  749.     indexLeaf(temp);
  750.     while (isAp(t)) {
  751.     indexType(arg(t),o);
  752.     t = fun(t);
  753.     deRef(tyv,t,o);
  754.     }
  755. }
  756.  
  757. static Void local indexLeaf(lf)        /* adjust pointers into current idx*/
  758. Cell lf; {                /* having detected type constructor*/
  759.     if (currIdx==NOIDX) {        /* lf whilst indexing over a type  */
  760.     if (lastIdx==NOIDX)
  761.         lastIdx = firstIdx = newIdx(lf);
  762.     else
  763.         lastIdx = idx(lastIdx).match = newIdx(lf);
  764.     currIdx = NOIDX;
  765.     }
  766.     else {
  767.     while (idx(currIdx).test!=lf) {
  768.         if (idx(currIdx).fail==NOIDX) {
  769.         lastIdx = idx(currIdx).fail = newIdx(lf);
  770.         currIdx = NOIDX;
  771.         return;
  772.         }
  773.         else
  774.         currIdx = idx(currIdx).fail;
  775.     }
  776.     lastIdx = currIdx;
  777.     currIdx = idx(currIdx).match;
  778.     }
  779. }
  780.  
  781. Dict listMonadDict() {            /* look for a dict for Monad [ ]   */
  782.     if (nonNull(classMonad)) {
  783.     currIdx = class(classMonad).dictIndex;
  784.     while (currIdx!=NOIDX && idx(currIdx).test!=LIST)
  785.         currIdx = idx(currIdx).fail;
  786.     if (currIdx!=NOIDX)
  787.         return idx(currIdx).match;
  788.     }
  789.     return NODICT;
  790. }
  791.  
  792. /*-------------------------------------------------------------------------*/
  793.